home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / places.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1995-05-24  |  49.0 KB  |  1,072 lines
  1. ; CLISP - PLACES.LSP
  2. ; CLISP-spezifisch: string-concat, %rplaca, %rplacd, store, %setelt, ...
  3.  
  4. (in-package "SYSTEM")
  5. ;-------------------------------------------------------------------------------
  6. ; Funktionen zur Definition und zum Ausnutzen von places:
  7. ;-------------------------------------------------------------------------------
  8. (defun setf-symbol (symbol) ; liefert uninterniertes Symbol fⁿr SYSTEM::SETF-FUNCTION
  9.   (make-symbol
  10.     (string-concat
  11.       "(SETF "
  12.       (let ((pack (symbol-package symbol))) (if pack (package-name pack) "#"))
  13.       ":"
  14.       (symbol-name symbol)
  15.       ")"
  16. ) ) )
  17. ;-------------------------------------------------------------------------------
  18. (defun get-setf-symbol (symbol) ; liefert das Symbol bei SYSTEM::SETF-FUNCTION
  19.   (or (get symbol 'SYSTEM::SETF-FUNCTION)
  20.       (progn
  21.         (when (get symbol 'SYSTEM::SETF-EXPANDER)
  22.           (warn (DEUTSCH "Die Funktion (~S ~S) ist durch einen SETF-Expander verborgen."
  23.                  ENGLISH "The function (~S ~S) is hidden by a SETF expander."
  24.                  FRANCAIS "La fonction (~S ~S) est cachΘe par une mΘthode SETF.")
  25.                 'setf symbol
  26.         ) )
  27.         (setf (get symbol 'SYSTEM::SETF-FUNCTION) (setf-symbol symbol))
  28. ) )   )
  29. ;-------------------------------------------------------------------------------
  30. (defun get-funname-symbol (funname) ; Abbildung Funktionsname --> Symbol
  31.   (if (atom funname)
  32.     funname
  33.     (get-setf-symbol (second funname))
  34. ) )
  35. ;-------------------------------------------------------------------------------
  36. (defun get-setf-method-multiple-value (form &optional (env (vector nil nil)))
  37.   (loop
  38.     ; 1. Schritt: nach globalen SETF-Definitionen suchen:
  39.     (when (and (consp form) (symbolp (car form)))
  40.       (when (global-in-fenv-p (car form) (svref env 1))
  41.         ; Operator nicht lokal definiert
  42.         (let ((plist-info (get (first form) 'SYSTEM::SETF-EXPANDER)))
  43.           (when plist-info
  44.             (return-from get-setf-method-multiple-value
  45.               (if (symbolp plist-info) ; Symbol kommt von kurzem DEFSETF
  46.                 (do* ((storevar (gensym))
  47.                       (tempvars nil (cons (gensym) tempvars))
  48.                       (tempforms nil (cons (car formr) tempforms))
  49.                       (formr (cdr form) (cdr formr)))
  50.                      ((atom formr)
  51.                       (setq tempforms (nreverse tempforms))
  52.                       (values tempvars
  53.                               tempforms
  54.                               `(,storevar)
  55.                               `(,plist-info ,@tempvars ,storevar)
  56.                               `(,(first form) ,@tempvars)
  57.                      ))
  58.                 )
  59.                 (let ((argcount (car plist-info)))
  60.                   (if (eql argcount -5)
  61.                     ; (-5 . fun) kommt von DEFINE-SETF-METHOD
  62.                     (funcall (cdr plist-info) form env)
  63.                     ; (argcount . fun) kommt von langem DEFSETF
  64.                     (let ((access-form form)
  65.                           (tempvars '())
  66.                           (tempforms '())
  67.                           (new-access-form '()))
  68.                       (let ((i 0)) ; Argumente-ZΣhler
  69.                         ; argcount = -1 falls keine Keyword-Argumente existieren
  70.                         ; bzw.     = Anzahl der einzelnen Argumente vor &KEY,
  71.                         ;          = nil nachdem diese abgearbeitet sind.
  72.                         (dolist (argform (cdr access-form))
  73.                           (when (eql i argcount) (setf argcount nil i 0))
  74.                           (if (and (null argcount) (evenp i))
  75.                             (if (keywordp argform)
  76.                               (push argform new-access-form)
  77.                               (error-of-type 'program-error
  78.                                 (DEUTSCH "Das Argument ~S zu ~S sollte ein Keyword sein."
  79.                                  ENGLISH "The argument ~S to ~S should be a keyword."
  80.                                  FRANCAIS "L'argument ~S de ~S doit Ωtre un mot-clΘ.")
  81.                                 argform (car access-form)
  82.                             ) )
  83.                             (let ((tempvar (gensym)))
  84.                               (push tempvar tempvars)
  85.                               (push argform tempforms)
  86.                               (push tempvar new-access-form)
  87.                           ) )
  88.                           (incf i)
  89.                       ) )
  90.                       (setq new-access-form
  91.                         (cons (car access-form) (nreverse new-access-form))
  92.                       )
  93.                       (let ((newval-var (gensym)))
  94.                         (values
  95.                           (nreverse tempvars)
  96.                           (nreverse tempforms)
  97.                           (list newval-var)
  98.                           (funcall (cdr plist-info) new-access-form newval-var)
  99.                           new-access-form
  100.                 ) ) ) ) )
  101.             ) )
  102.     ) ) ) )
  103.     ; 2. Schritt: macroexpandieren
  104.     (when (eq form (setq form (macroexpand-1 form env)))
  105.       (return)
  106.   ) )
  107.   ; 3. Schritt: Default-SETF-Methoden
  108.   (cond ((symbolp form)
  109.          (return-from get-setf-method-multiple-value
  110.            (let ((storevar (gensym)))
  111.              (values nil
  112.                      nil
  113.                      `(,storevar)
  114.                      `(SETQ ,form ,storevar)
  115.                      `,form
  116.         )) ) )
  117.         ((and (consp form) (symbolp (car form)))
  118.          (return-from get-setf-method-multiple-value
  119.            (do* ((storevar (gensym))
  120.                  (tempvars nil (cons (gensym) tempvars))
  121.                  (tempforms nil (cons (car formr) tempforms))
  122.                  (formr (cdr form) (cdr formr)))
  123.                 ((atom formr)
  124.                  (setq tempforms (nreverse tempforms))
  125.                  (values tempvars
  126.                          tempforms
  127.                          `(,storevar)
  128.                          `((SETF ,(first form)) ,storevar ,@tempvars)
  129.                          `(,(first form) ,@tempvars)
  130.                 ))
  131.         )) )
  132.         (t (error-of-type 'program-error
  133.              (DEUTSCH "Das Argument mu▀ eine 'SETF-place' sein, ist aber keine: ~S"
  134.               ENGLISH "Argument ~S is not a SETF place."
  135.               FRANCAIS "L'argument ~S doit reprΘsenter une place modifiable.")
  136.              form
  137.   )     )  )
  138. )
  139. ;-------------------------------------------------------------------------------
  140. (defun get-setf-method (form &optional (env (vector nil nil)))
  141.   (multiple-value-bind (vars vals stores store-form access-form)
  142.       (get-setf-method-multiple-value form env)
  143.     (unless (and (consp stores) (null (cdr stores)))
  144.       (error-of-type 'program-error
  145.         (DEUTSCH "Diese 'SETF-place' produziert mehrere 'Store-Variable': ~S"
  146.          ENGLISH "SETF place ~S produces more than one store variable."
  147.          FRANCAIS "La place modifiable ~S produit plusieurs variables de rΘsultat.")
  148.         form
  149.     ) )
  150.     (values vars vals stores store-form access-form)
  151. ) )
  152. ;-------------------------------------------------------------------------------
  153. ; In einfachen Zuweisungen wie (SETQ foo #:G0) darf #:G0 direkt ersetzt werden.
  154. (defun simple-assignment-p (store-form stores)
  155.   (and (eql (length stores) 1)
  156.        (consp store-form)
  157.        (eq (first store-form) 'SETQ)
  158.        (eql (length store-form) 3)
  159.        (symbolp (second store-form))
  160.        (simple-use-p (third store-form) (first stores))
  161. ) )
  162. (defun simple-use-p (form var)
  163.   (or (eq form var)
  164.       (and (consp form) (eq (first form) 'THE) (eql (length form) 3)
  165.            (simple-use-p (third form) var)
  166. ) )   )
  167. ;-------------------------------------------------------------------------------
  168. (defun documentation (symbol doctype)
  169.   (unless (function-name-p symbol)
  170.     (error-of-type 'error
  171.       (DEUTSCH "~S: Das ist als erstes Argument unzulΣssig, da kein Symbol: ~S"
  172.        ENGLISH "~S: first argument ~S is illegal, not a symbol"
  173.        FRANCAIS "~S : Le premier argument ~S est invalide car ce n'est pas un symbole.")
  174.       'documentation symbol
  175.   ) )
  176.   (getf (get (get-funname-symbol symbol) 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  177. )
  178. (defun SYSTEM::%SET-DOCUMENTATION (symbol doctype value)
  179.   (unless (function-name-p symbol)
  180.     (error-of-type 'error
  181.       (DEUTSCH "~S: Das ist als erstes Argument unzulΣssig, da kein Symbol: ~S"
  182.        ENGLISH "~S: first argument ~S is illegal, not a symbol"
  183.        FRANCAIS "~S : Le premier argument ~S est invalide car ce n'est pas un symbole.")
  184.       'documentation symbol
  185.   ) )
  186.   (setq symbol (get-funname-symbol symbol))
  187.   (if (null value)
  188.     (when (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  189.       (remf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  190.       nil
  191.     )
  192.     (setf (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype) value)
  193. ) )
  194. ;-------------------------------------------------------------------------------
  195. (defmacro push (item place &environment env)
  196.   (let ((itemvar (gensym)))
  197.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  198.       (let ((bindlist (mapcar #'list SM1 SM2)))
  199.         (if bindlist
  200.           (push `(,itemvar ,item) bindlist)
  201.           (setq itemvar item)
  202.         )
  203.         (let ((valform `(CONS ,itemvar ,SM5)))
  204.           (if (simple-assignment-p SM4 SM3)
  205.             (setq SM4 (subst valform (first SM3) SM4))
  206.             (setq bindlist (nconc bindlist `((,(first SM3) ,valform))))
  207.           )
  208.           (if bindlist
  209.             `(LET* ,bindlist
  210.                ,SM4
  211.              )
  212.             SM4
  213.           )
  214. ) ) ) ) )
  215. ;-------------------------------------------------------------------------------
  216. (defmacro define-setf-method (accessfn lambdalist &body body &environment env)
  217.   (unless (symbolp accessfn)
  218.     (error-of-type 'program-error
  219.       (DEUTSCH "Der Name der Access-Function mu▀ ein Symbol sein und nicht ~S."
  220.        ENGLISH "The name of the access function must be a symbol, not ~S"
  221.        FRANCAIS "Le nom de la fonction d'accΦs doit Ωtre un symbole et non ~S.")
  222.       accessfn
  223.   ) )
  224.   (multiple-value-bind (body-rest declarations docstring)
  225.       (system::parse-body body t env)
  226.     (if (null body-rest) (setq body-rest '(NIL)))
  227.     (let ((name (make-symbol (string-concat "SETF-" (symbol-name accessfn)))))
  228.       (multiple-value-bind (newlambdalist envvar) (remove-env-arg lambdalist name)
  229.         (let ((SYSTEM::%ARG-COUNT 0)
  230.               (SYSTEM::%MIN-ARGS 0)
  231.               (SYSTEM::%RESTP nil)
  232.               (SYSTEM::%LET-LIST nil)
  233.               (SYSTEM::%KEYWORD-TESTS nil)
  234.               (SYSTEM::%DEFAULT-FORM nil)
  235.              )
  236.           (SYSTEM::ANALYZE1 newlambdalist '(CDR SYSTEM::%LAMBDA-LIST)
  237.                             name 'SYSTEM::%LAMBDA-LIST
  238.           )
  239.           (if (null newlambdalist)
  240.             (push `(IGNORE SYSTEM::%LAMBDA-LIST) declarations)
  241.           )
  242.           (let ((lengthtest (sys::make-length-test 'SYSTEM::%LAMBDA-LIST))
  243.                 (mainform
  244.                   `(LET* ,(nreverse SYSTEM::%LET-LIST)
  245.                      ,@(if declarations `(,(cons 'DECLARE declarations)))
  246.                      ,@SYSTEM::%KEYWORD-TESTS
  247.                      (BLOCK ,accessfn ,@body-rest)
  248.                    )
  249.                ))
  250.             (if lengthtest
  251.               (setq mainform
  252.                 `(IF ,lengthtest
  253.                    (ERROR-OF-TYPE 'PROGRAM-ERROR
  254.                      (DEUTSCH "Der SETF-Expander fⁿr ~S kann nicht mit ~S Argumenten aufgerufen werden."
  255.                       ENGLISH "The SETF expander for ~S may not be called with ~S arguments."
  256.                       FRANCAIS "L'½expandeur╗ SETF pour ~S ne peut pas Ωtre appelΘ avec ~S arguments.")
  257.                      (QUOTE ,accessfn) (1- (LENGTH SYSTEM::%LAMBDA-LIST))
  258.                    )
  259.                    ,mainform
  260.               )  )
  261.             )
  262.             `(EVAL-WHEN (LOAD COMPILE EVAL)
  263.                (LET ()
  264.                  (DEFUN ,name (SYSTEM::%LAMBDA-LIST ,(or envvar 'SYSTEM::ENV))
  265.                    ,@(if envvar '() '((DECLARE (IGNORE SYSTEM::ENV))))
  266.                    ,mainform
  267.                  )
  268.                  (SYSTEM::%PUT ',accessfn 'SYSTEM::SETF-EXPANDER
  269.                    (CONS -5 (FUNCTION ,name))
  270.                  )
  271.                  (SYSTEM::%SET-DOCUMENTATION ',accessfn 'SETF ',docstring)
  272.                  ',accessfn
  273.              ) )
  274. ) ) ) ) ) )
  275. ;-------------------------------------------------------------------------------
  276. (defmacro defsetf (accessfn &rest args &environment env)
  277.   (cond ((and (consp args) (not (listp (first args))) (symbolp (first args)))
  278.          `(EVAL-WHEN (LOAD COMPILE EVAL)
  279.             (LET ()
  280.               (SYSTEM::%PUT ',accessfn 'SYSTEM::SETF-EXPANDER ',(first args))
  281.               (SYSTEM::%SET-DOCUMENTATION ',accessfn 'SETF
  282.                 ,(if (and (null (cddr args))
  283.                           (or (null (second args)) (stringp (second args)))
  284.                      )
  285.                    (second args)
  286.                    (if (cddr args)
  287.                      (error-of-type 'program-error
  288.                        (DEUTSCH "Zu viele Argumente fⁿr DEFSETF: ~S"
  289.                         ENGLISH "Too many arguments to DEFSETF: ~S"
  290.                         FRANCAIS "Trop d'arguments pour DEFSETF : ~S")
  291.                        (cdr args)
  292.                      )
  293.                      (error-of-type 'program-error
  294.                        (DEUTSCH "Der Dok.-String zu DEFSETF mu▀ ein String sein: ~S"
  295.                         ENGLISH "The doc string to DEFSETF must be a string: ~S"
  296.                         FRANCAIS "La documentation pour DEFSETF doit Ωtre un chaεne : ~S")
  297.                        (second args)
  298.                  ) ) )
  299.               )
  300.               ',accessfn
  301.           ) )
  302.         )
  303.         ((and (consp args) (listp (first args)) (consp (cdr args)) (listp (second args)))
  304.          (cond ((= (length (second args)) 1))
  305.                ((= (length (second args)) 0)
  306.                 (error-of-type 'program-error
  307.                   (DEUTSCH "Bei DEFSETF mu▀ genau eine 'Store-Variable' angegeben werden."
  308.                    ENGLISH "Missing store variable in DEFSETF."
  309.                    FRANCAIS "Une variable de rΘsultat doit Ωtre prΘcisΘe dans DEFSETF.")
  310.                ))
  311.                (t (cerror (DEUTSCH "Die ⁿberzΣhligen Variablen werden ignoriert."
  312.                            ENGLISH "The excess variables will be ignored."
  313.                            FRANCAIS "Les variables en excΦs seront ignorΘes.")
  314.                           (DEUTSCH "Bei DEFSETF ist nur eine 'Store-Variable' erlaubt."
  315.                            ENGLISH "Only one store variable is allowed in DEFSETF."
  316.                            FRANCAIS "Une seule variable de rΘsultat est permise dans DEFSETF.")
  317.          )     )  )
  318.          (multiple-value-bind (body-rest declarations docstring)
  319.              (system::parse-body (cddr args) t env)
  320.            (let* (arg-count
  321.                   (setter
  322.                     (let* ((lambdalist (first args))
  323.                            (storevar (first (second args)))
  324.                            (SYSTEM::%ARG-COUNT 0)
  325.                            (SYSTEM::%MIN-ARGS 0)
  326.                            (SYSTEM::%RESTP nil)
  327.                            (SYSTEM::%LET-LIST nil)
  328.                            (SYSTEM::%KEYWORD-TESTS nil)
  329.                            (SYSTEM::%DEFAULT-FORM nil))
  330.                       (SYSTEM::ANALYZE1 lambdalist '(CDR SYSTEM::%ACCESS-ARGLIST)
  331.                                         accessfn 'SYSTEM::%ACCESS-ARGLIST
  332.                       )
  333.                       (setq arg-count (if (member '&KEY lambdalist) SYSTEM::%ARG-COUNT -1))
  334.                       (when declarations (setq declarations `((DECLARE ,@declarations))))
  335.                       `(LAMBDA (SYSTEM::%ACCESS-ARGLIST ,storevar)
  336.                          ,@(if (null lambdalist)
  337.                              `((DECLARE (IGNORE SYSTEM::%ACCESS-ARGLIST)))
  338.                            )
  339.                          ,@declarations
  340.                          (LET* ,(nreverse SYSTEM::%LET-LIST)
  341.                            ,@declarations
  342.                            ,@SYSTEM::%KEYWORD-TESTS
  343.                            (BLOCK ,accessfn ,@body-rest)
  344.                        ) )
  345.                  )) )
  346.              `(EVAL-WHEN (LOAD COMPILE EVAL)
  347.                 (LET ()
  348.                   (SYSTEM::%PUT ',accessfn 'SYSTEM::SETF-EXPANDER
  349.                     (CONS ,arg-count
  350.                           (FUNCTION ,(concat-pnames "SETF-" accessfn) ,setter)
  351.                   ) )
  352.                   (SYSTEM::%SET-DOCUMENTATION ',accessfn 'SETF ,docstring)
  353.                   ',accessfn
  354.               ) )
  355.         )) )
  356.         (t (error-of-type 'program-error
  357.              (DEUTSCH "DEFSETF-Aufruf fⁿr ~S ist falsch aufgebaut."
  358.               ENGLISH "Illegal syntax in DEFSETF for ~S"
  359.               FRANCAIS "Le DEFSETF ~S est mal formΘ.")
  360.              accessfn
  361. ) )     )  )
  362. ;-------------------------------------------------------------------------------
  363. (defmacro pop (place &environment env)
  364.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  365.     (do* ((SM1r SM1 (cdr SM1r))
  366.           (SM2r SM2 (cdr SM2r))
  367.           (bindlist nil))
  368.          ((null SM1r)
  369.           (let* ((valform
  370.                    (if (and (symbolp SM5) (simple-assignment-p SM4 SM3))
  371.                      SM5
  372.                      (progn (push `(,(first SM3) ,SM5) bindlist) (first SM3))
  373.                  ) )
  374.                  (newvalform `(CDR ,valform))
  375.                  (form `(PROG1
  376.                           (CAR ,valform)
  377.                           ,@(if (simple-assignment-p SM4 SM3)
  378.                               (list (subst newvalform (first SM3) SM4))
  379.                               (list `(SETQ ,(first SM3) ,newvalform) SM4)
  380.                             )
  381.                         )
  382.                 ))
  383.             (if bindlist
  384.               `(LET* ,(nreverse bindlist) ,form)
  385.               form
  386.          )) )
  387.       (push `(,(first SM1r) ,(first SM2r)) bindlist)
  388. ) ) )
  389. ;-------------------------------------------------------------------------------
  390. (defmacro psetf (&whole form &rest args &environment env)
  391.   (do ((arglist args (cddr arglist))
  392.        (bindlist nil)
  393.        (storelist nil))
  394.       ((atom arglist)
  395.        `(LET* ,(nreverse bindlist)
  396.           ,@storelist
  397.           NIL
  398.       ) )
  399.     (when (atom (cdr arglist))
  400.       (error-of-type 'program-error
  401.         (DEUTSCH "~S mit einer ungeraden Zahl von Argumenten aufgerufen: ~S"
  402.          ENGLISH "~S called with an odd number of arguments: ~S"
  403.          FRANCAIS "~S fut appelΘ avec un nombre impair d'arguments : ~S")
  404.         'psetf form
  405.     ) )
  406.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method (first arglist) env)
  407.       (declare (ignore SM5))
  408.       (do* ((SM1r SM1 (cdr SM1r))
  409.             (SM2r SM2 (cdr SM2r)))
  410.            ((null SM1r))
  411.         (push `(,(first SM1r) ,(first SM2r)) bindlist)
  412.       )
  413.       (push `(,(first SM3) ,(second arglist)) bindlist)
  414.       (push SM4 storelist)
  415. ) ) )
  416. ;-------------------------------------------------------------------------------
  417. (defmacro pushnew (item place &rest keylist &environment env)
  418.   (let ((itemvar (gensym)))
  419.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  420.       (let ((bindlist (mapcar #'list SM1 SM2)))
  421.         (if bindlist
  422.           (push `(,itemvar ,item) bindlist)
  423.           (setq itemvar item)
  424.         )
  425.         (let ((valform `(ADJOIN ,itemvar ,SM5 ,@keylist)))
  426.           (if (simple-assignment-p SM4 SM3)
  427.             (setq SM4 (subst valform (first SM3) SM4))
  428.             (setq bindlist (nconc bindlist `((,(first SM3) ,valform))))
  429.           )
  430.           (if bindlist
  431.             `(LET* ,bindlist
  432.                ,SM4
  433.              )
  434.             SM4
  435.           )
  436. ) ) ) ) )
  437. ;-------------------------------------------------------------------------------
  438. (defmacro remf (place indicator &environment env)
  439.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  440.     (do* ((SM1r SM1 (cdr SM1r))
  441.           (SM2r SM2 (cdr SM2r))
  442.           (bindlist nil)
  443.           (indicatorvar (gensym))
  444.           (var1 (gensym))
  445.           (var2 (gensym)))
  446.          ((null SM1r)
  447.           (push `(,(first SM3) ,SM5) bindlist)
  448.           (push `(,indicatorvar ,indicator) bindlist)
  449.           `(LET* ,(nreverse bindlist)
  450.              (DO ((,var1 ,(first SM3) (CDDR ,var1))
  451.                   (,var2 NIL ,var1))
  452.                  ((ATOM ,var1) NIL)
  453.                (COND ((ATOM (CDR ,var1))
  454.                       (ERROR-OF-TYPE 'ERROR
  455.                         (DEUTSCH "REMF: Property-Liste ungerader LΣnge aufgetreten."
  456.                          ENGLISH "REMF: property list with an odd length"
  457.                          FRANCAIS "REMF : Occurence d'une liste de propriΘtΘs de longueur impaire.")
  458.                      ))
  459.                      ((EQ (CAR ,var1) ,indicatorvar)
  460.                       (IF ,var2
  461.                         (RPLACD (CDR ,var2) (CDDR ,var1))
  462.                         ,(let ((newvalform `(CDDR ,(first SM3))))
  463.                            (if (simple-assignment-p SM4 SM3)
  464.                              (subst newvalform (first SM3) SM4)
  465.                              `(PROGN (SETQ ,(first SM3) ,newvalform) ,SM4)
  466.                          ) )
  467.                       )
  468.                       (RETURN T)
  469.            ) ) )     )
  470.          )
  471.       (push `(,(first SM1r) ,(first SM2r)) bindlist)
  472. ) ) )
  473. ;-------------------------------------------------------------------------------
  474. (defmacro rotatef (&rest args &environment env)
  475.   (cond ((null args) NIL)
  476.         ((null (cdr args)) `(PROGN ,(car args) NIL) )
  477.         (t (do* ((arglist args (cdr arglist))
  478.                  (bindlist nil)
  479.                  (storelist nil)
  480.                  (lastvar nil)
  481.                  (firstbind nil))
  482.                 ((atom arglist)
  483.                  (setf (car firstbind) lastvar)
  484.                  `(LET* ,(nreverse bindlist) ,@(nreverse storelist) NIL)
  485.                 )
  486.              (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  487.                  (get-setf-method (first arglist) env)
  488.                (do* ((SM1r SM1 (cdr SM1r))
  489.                      (SM2r SM2 (cdr SM2r)))
  490.                     ((null SM1r))
  491.                  (push `(,(first SM1r) ,(first SM2r)) bindlist)
  492.                )
  493.                (push `(,lastvar ,SM5) bindlist)
  494.                (if (null firstbind) (setq firstbind (first bindlist)))
  495.                (push SM4 storelist)
  496.                (setq lastvar (first SM3))
  497. ) )     )  ) )
  498. ;-------------------------------------------------------------------------------
  499. (defmacro define-modify-macro (name lambdalist function &optional docstring)
  500.   (let* ((varlist nil)
  501.          (restvar nil))
  502.     (do* ((lambdalistr lambdalist (cdr lambdalistr))
  503.           (next))
  504.          ((null lambdalistr))
  505.       (setq next (first lambdalistr))
  506.       (cond ((eq next '&OPTIONAL))
  507.             ((eq next '&REST)
  508.              (if (symbolp (second lambdalistr))
  509.                (setq restvar (second lambdalistr))
  510.                (error-of-type 'program-error
  511.                  (DEUTSCH "In der Definition von ~S ist die &REST-Variable kein Symbol: ~S"
  512.                   ENGLISH "In the definition of ~S: &REST variable ~S should be a symbol."
  513.                   FRANCAIS "Dans la dΘfinition de ~S la variable pour &REST n'est pas un symbole : ~S.")
  514.                  name (second lambdalistr)
  515.              ) )
  516.              (if (null (cddr lambdalistr))
  517.                (return)
  518.                (error-of-type 'program-error
  519.                  (DEUTSCH "Nach &REST ist nur eine Variable erlaubt; es kam: ~S"
  520.                   ENGLISH "Only one variable is allowed after &REST, not ~S"
  521.                   FRANCAIS "Une seule variable est permise pour &REST et non ~S.")
  522.                  lambdalistr
  523.             )) )
  524.             ((or (eq next '&KEY) (eq next '&ALLOW-OTHER-KEYS) (eq next '&AUX))
  525.              (error-of-type 'program-error
  526.                (DEUTSCH "In einer DEFINE-MODIFY-MACRO-Lambdaliste ist ~S unzulΣssig."
  527.                 ENGLISH "Illegal in a DEFINE-MODIFY-MACRO lambda list: ~S"
  528.                 FRANCAIS "~S n'est pas permis dans une liste lambda pour DEFINE-MODIFY-MACRO.")
  529.                next
  530.             ))
  531.             ((symbolp next) (push next varlist))
  532.             ((and (listp next) (symbolp (first next)))
  533.              (push (first next) varlist)
  534.             )
  535.             (t (error-of-type 'program-error
  536.                  (DEUTSCH "Lambdalisten dⁿrfen nur Symbole und Listen enthalten, nicht aber ~S"
  537.                   ENGLISH "lambda list may only contain symbols and lists, not ~S"
  538.                   FRANCAIS "Les listes lambda ne peuvent contenir que des symboles et des listes et non ~S.")
  539.                  next
  540.             )  )
  541.     ) )
  542.     (setq varlist (nreverse varlist))
  543.     `(DEFMACRO ,name (%REFERENCE ,@lambdalist &ENVIRONMENT ENV) ,docstring
  544.        (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
  545.            (GET-SETF-METHOD %REFERENCE ENV)
  546.          (DO ((D DUMMIES (CDR D))
  547.               (V VALS (CDR V))
  548.               (LET-LIST NIL (CONS (LIST (CAR D) (CAR V)) LET-LIST)))
  549.              ((NULL D)
  550.               (WHEN (SYMBOLP GETTER)
  551.                 (RETURN
  552.                   (SUBST
  553.                     (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar)
  554.                     (CAR NEWVAL)
  555.                     SETTER
  556.               ) ) )
  557.               (PUSH
  558.                 (LIST
  559.                   (CAR NEWVAL)
  560.                   (IF (AND (LISTP %REFERENCE) (EQ (CAR %REFERENCE) 'THE))
  561.                     (LIST 'THE (CADR %REFERENCE)
  562.                       (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar)
  563.                     )
  564.                     (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar)
  565.                 ) )
  566.                 LET-LIST
  567.               )
  568.               (LIST 'LET* (NREVERSE LET-LIST) SETTER)
  569.      ) ) ) )
  570. ) )
  571. ;-------------------------------------------------------------------------------
  572. (define-modify-macro decf (&optional (delta 1)) -)
  573. ;-------------------------------------------------------------------------------
  574. (define-modify-macro incf (&optional (delta 1)) +)
  575. ;-------------------------------------------------------------------------------
  576. (defmacro setf (&whole form &rest args &environment env)
  577.   (let ((argcount (length args)))
  578.     (cond ((eql argcount 2)
  579.            (let* ((place (first args))
  580.                   (value (second args)))
  581.              (loop
  582.                ; 1. Schritt: nach globalen SETF-Definitionen suchen:
  583.                (when (and (consp place) (symbolp (car place)))
  584.                  (when (global-in-fenv-p (car place) (svref env 1))
  585.                    ; Operator nicht lokal definiert
  586.                    (let ((plist-info (get (first place) 'SYSTEM::SETF-EXPANDER)))
  587.                      (when plist-info
  588.                        (return-from setf
  589.                          (cond ((symbolp plist-info) ; Symbol kommt von kurzem DEFSETF
  590.                                 `(,plist-info ,@(cdr place) ,value)
  591.                                )
  592.                                ((and (eq (first place) 'THE) (eql (length place) 3))
  593.                                 `(SETF ,(third place) (THE ,(second place) ,value))
  594.                                )
  595.                                ((and (eq (first place) 'VALUES-LIST) (eql (length place) 2))
  596.                                 `(VALUES-LIST
  597.                                    (SETF ,(second place)
  598.                                          (MULTIPLE-VALUE-LIST ,value)
  599.                                ) ) )
  600.                                (t
  601.                                 (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  602.                                     (get-setf-method-multiple-value place env)
  603.                                   (declare (ignore SM5))
  604.                                   (do* ((SM1r SM1 (cdr SM1r))
  605.                                         (SM2r SM2 (cdr SM2r))
  606.                                         (bindlist nil))
  607.                                        ((null SM1r)
  608.                                         (if (eql (length SM3) 1) ; eine Store-Variable
  609.                                           `(LET* ,(nreverse
  610.                                                     (cons `(,(first SM3) ,value)
  611.                                                           bindlist
  612.                                                   ) )
  613.                                              ,SM4
  614.                                            )
  615.                                           ; mehrere Store-Variable
  616.                                           (if
  617.                                             ; Hat SM4 die Gestalt
  618.                                             ; (VALUES (SETQ v1 store1) ...) ?
  619.                                             (and (consp SM4) (eq (car SM4) 'VALUES)
  620.                                               (do ((SM3r SM3 (cdr SM3r))
  621.                                                    (SM4r (cdr SM4) (cdr SM4r)))
  622.                                                   ((or (null SM3r) (null SM4r))
  623.                                                    (and (null SM3r) (null SM4r))
  624.                                                   )
  625.                                                 (unless (simple-assignment-p (car SM4r) (list (car SM3r)))
  626.                                                   (return nil)
  627.                                             ) ) )
  628.                                             (let ((vlist (mapcar #'second (rest SM4))))
  629.                                               `(LET* ,(nreverse bindlist)
  630.                                                  (MULTIPLE-VALUE-SETQ ,vlist ,value)
  631.                                                  (VALUES ,@vlist)
  632.                                             )  )
  633.                                             `(LET* ,(nreverse bindlist)
  634.                                                (MULTIPLE-VALUE-BIND ,SM3 ,value
  635.                                                  ,SM4
  636.                                              ) )
  637.                                        )) )
  638.                                     (push `(,(first SM1r) ,(first SM2r)) bindlist)
  639.                        ) )     )) )
  640.                ) ) ) )
  641.                ; 2. Schritt: macroexpandieren
  642.                (when (eq place (setq place (macroexpand-1 place env)))
  643.                  (return)
  644.              ) )
  645.              ; 3. Schritt: Default-SETF-Methoden
  646.              (cond ((symbolp place)
  647.                     `(SETQ ,place ,value)
  648.                    )
  649.                    ((and (consp form) (symbolp (car form)))
  650.                     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  651.                         (get-setf-method-multiple-value place env)
  652.                       (declare (ignore SM5))
  653.                       ; SM4 hat die Gestalt `((SETF ,(first place)) ,@SM3 ,@SM1).
  654.                       ; SM3 ist ⁿberflⁿssig.
  655.                       `(LET* ,(mapcar #'list SM1 SM2)
  656.                          ,(subst value (first SM3) SM4)
  657.                        )
  658.                    ))
  659.                    (t (error-of-type 'program-error
  660.                         (DEUTSCH "Das ist keine erlaubte 'SETF-Place' : ~S"
  661.                          ENGLISH "Illegal SETF place: ~S"
  662.                          FRANCAIS "Ceci n'est pas une place modifiable valide : ~S")
  663.                         (first args)
  664.              )     )  )
  665.           ))
  666.           ((oddp argcount)
  667.            (error-of-type 'program-error
  668.              (DEUTSCH "~S mit einer ungeraden Zahl von Argumenten aufgerufen: ~S"
  669.               ENGLISH "~S called with an odd number of arguments: ~S"
  670.               FRANCAIS "~S fut appelΘ avec un nombre impair d'arguments : ~S")
  671.              'setf form
  672.           ))
  673.           (t (do* ((arglist args (cddr arglist))
  674.                    (L nil))
  675.                   ((null arglist) `(LET () (PROGN ,@(nreverse L))))
  676.                (push `(SETF ,(first arglist) ,(second arglist)) L)
  677.           )  )
  678. ) ) )
  679. ;-------------------------------------------------------------------------------
  680. (defmacro shiftf (&whole form &rest args &environment env)
  681.   (when (< (length args) 2)
  682.     (error-of-type 'program-error
  683.       (DEUTSCH "SHIFTF mit zu wenig Argumenten aufgerufen: ~S"
  684.        ENGLISH "SHIFTF called with too few arguments: ~S"
  685.        FRANCAIS "SHIFTF fut appelΘ avec trop peu d'arguments : ~S")
  686.       form
  687.   ) )
  688.   (do* ((resultvar (gensym))
  689.         (arglist args (cdr arglist))
  690.         (bindlist nil)
  691.         (storelist nil)
  692.         (lastvar resultvar))
  693.        ((atom (cdr arglist))
  694.         (push `(,lastvar ,(first arglist)) bindlist)
  695.         `(LET* ,(nreverse bindlist) ,@(nreverse storelist) ,resultvar)
  696.        )
  697.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method (first arglist) env)
  698.       (do* ((SM1r SM1 (cdr SM1r))
  699.             (SM2r SM2 (cdr SM2r)))
  700.            ((null Sm1r))
  701.         (push `(,(first SM1r) ,(first SM2r)) bindlist)
  702.       )
  703.       (push `(,lastvar ,SM5) bindlist)
  704.       (push SM4 storelist)
  705.       (setq lastvar (first SM3))
  706. ) ) )
  707. ;-------------------------------------------------------------------------------
  708. ; Definition von places:
  709. ;-------------------------------------------------------------------------------
  710. (defsetf aref (array &rest indices) (value)
  711.   `(SYSTEM::STORE ,array ,@indices ,value)
  712. )
  713. ;-------------------------------------------------------------------------------
  714. (defun SYSTEM::%SETNTH (index list value)
  715.   (let ((pointer (nthcdr index list)))
  716.     (if (null pointer)
  717.       (error-of-type 'error
  718.         (DEUTSCH "(SETF (NTH ...) ...) : Index ~S ist zu gro▀ fⁿr ~S."
  719.          ENGLISH "(SETF (NTH ...) ...) : index ~S is too large for ~S"
  720.          FRANCAIS "(SETF (NTH ...) ...) : L'index ~S est trop grand pour ~S.")
  721.         index list
  722.       )
  723.       (rplaca pointer value)
  724.     )
  725.     value
  726. ) )
  727. (defsetf nth SYSTEM::%SETNTH)
  728. ;-------------------------------------------------------------------------------
  729. (defsetf elt SYSTEM::%SETELT)
  730. ;-------------------------------------------------------------------------------
  731. (defsetf rest SYSTEM::%RPLACD)
  732. (defsetf first SYSTEM::%RPLACA)
  733. (defsetf second (list) (value) `(SYSTEM::%RPLACA (CDR ,list) ,value))
  734. (defsetf third (list) (value) `(SYSTEM::%RPLACA (CDDR ,list) ,value))
  735. (defsetf fourth (list) (value) `(SYSTEM::%RPLACA (CDDDR ,list) ,value))
  736. (defsetf fifth (list) (value) `(SYSTEM::%RPLACA (CDDDDR ,list) ,value))
  737. (defsetf sixth (list) (value) `(SYSTEM::%RPLACA (CDR (CDDDDR ,list)) ,value))
  738. (defsetf seventh (list) (value) `(SYSTEM::%RPLACA (CDDR (CDDDDR ,list)) ,value))
  739. (defsetf eighth (list) (value) `(SYSTEM::%RPLACA (CDDDR (CDDDDR ,list)) ,value))
  740. (defsetf ninth (list) (value) `(SYSTEM::%RPLACA (CDDDDR (CDDDDR ,list)) ,value))
  741. (defsetf tenth (list) (value) `(SYSTEM::%RPLACA (CDR (CDDDDR (CDDDDR ,list))) ,value))
  742.  
  743. (defsetf car SYSTEM::%RPLACA)
  744. (defsetf cdr SYSTEM::%RPLACD)
  745. (defsetf caar (list) (value) `(SYSTEM::%RPLACA (CAR ,list) ,value))
  746. (defsetf cadr (list) (value) `(SYSTEM::%RPLACA (CDR ,list) ,value))
  747. (defsetf cdar (list) (value) `(SYSTEM::%RPLACD (CAR ,list) ,value))
  748. (defsetf cddr (list) (value) `(SYSTEM::%RPLACD (CDR ,list) ,value))
  749. (defsetf caaar (list) (value) `(SYSTEM::%RPLACA (CAAR ,list) ,value))
  750. (defsetf caadr (list) (value) `(SYSTEM::%RPLACA (CADR ,list) ,value))
  751. (defsetf cadar (list) (value) `(SYSTEM::%RPLACA (CDAR ,list) ,value))
  752. (defsetf caddr (list) (value) `(SYSTEM::%RPLACA (CDDR ,list) ,value))
  753. (defsetf cdaar (list) (value) `(SYSTEM::%RPLACD (CAAR ,list) ,value))
  754. (defsetf cdadr (list) (value) `(SYSTEM::%RPLACD (CADR ,list) ,value))
  755. (defsetf cddar (list) (value) `(SYSTEM::%RPLACD (CDAR ,list) ,value))
  756. (defsetf cdddr (list) (value) `(SYSTEM::%RPLACD (CDDR ,list) ,value))
  757. (defsetf caaaar (list) (value) `(SYSTEM::%RPLACA (CAAAR ,list) ,value))
  758. (defsetf caaadr (list) (value) `(SYSTEM::%RPLACA (CAADR ,list) ,value))
  759. (defsetf caadar (list) (value) `(SYSTEM::%RPLACA (CADAR ,list) ,value))
  760. (defsetf caaddr (list) (value) `(SYSTEM::%RPLACA (CADDR ,list) ,value))
  761. (defsetf cadaar (list) (value) `(SYSTEM::%RPLACA (CDAAR ,list) ,value))
  762. (defsetf cadadr (list) (value) `(SYSTEM::%RPLACA (CDADR ,list) ,value))
  763. (defsetf caddar (list) (value) `(SYSTEM::%RPLACA (CDDAR ,list) ,value))
  764. (defsetf cadddr (list) (value) `(SYSTEM::%RPLACA (CDDDR ,list) ,value))
  765. (defsetf cdaaar (list) (value) `(SYSTEM::%RPLACD (CAAAR ,list) ,value))
  766. (defsetf cdaadr (list) (value) `(SYSTEM::%RPLACD (CAADR ,list) ,value))
  767. (defsetf cdadar (list) (value) `(SYSTEM::%RPLACD (CADAR ,list) ,value))
  768. (defsetf cdaddr (list) (value) `(SYSTEM::%RPLACD (CADDR ,list) ,value))
  769. (defsetf cddaar (list) (value) `(SYSTEM::%RPLACD (CDAAR ,list) ,value))
  770. (defsetf cddadr (list) (value) `(SYSTEM::%RPLACD (CDADR ,list) ,value))
  771. (defsetf cdddar (list) (value) `(SYSTEM::%RPLACD (CDDAR ,list) ,value))
  772. (defsetf cddddr (list) (value) `(SYSTEM::%RPLACD (CDDDR ,list) ,value))
  773. ;-------------------------------------------------------------------------------
  774. (defsetf svref SYSTEM::SVSTORE)
  775. (defsetf row-major-aref system::row-major-store)
  776. ;-------------------------------------------------------------------------------
  777. (defsetf GET (symbol indicator &optional default) (value)
  778.   (let ((storeform `(SYSTEM::%PUT ,symbol ,indicator ,value)))
  779.     (if default
  780.       `(PROGN ,default ,storeform) ; default wird nur zum Schein ausgewertet
  781.       `,storeform
  782. ) ) )
  783. ;-------------------------------------------------------------------------------
  784. ; Schreibt zu einem bestimmten Indicator einen Wert in eine gegebene
  785. ; Propertyliste. Wert ist NIL falls erfolgreich getan oder die neue
  786. ; (erweiterte) Propertyliste.
  787. (defun sys::%putf (plist indicator value)
  788.   (do ((plistr plist (cddr plistr)))
  789.       ((atom plistr) (list* indicator value plist))
  790.     (when (atom (cdr plistr))
  791.       (error-of-type 'error
  792.         (DEUTSCH "(SETF (GETF ...) ...) : Property-Liste ungerader LΣnge aufgetaucht."
  793.          ENGLISH "(SETF (GETF ...) ...) : property list with an odd length"
  794.          FRANCAIS "(SETF (GETF ...) ...) : Occurence d'une liste de propriΘtΘs de longueur impaire.")
  795.     ))
  796.     (when (eq (car plistr) indicator)
  797.       (rplaca (cdr plistr) value)
  798.       (return nil)
  799. ) ) )
  800. (define-setf-method getf (place indicator &optional default &environment env)
  801.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  802.     (let* ((storevar (gensym))
  803.            (indicatorvar (gensym))
  804.            (defaultvar-list (if default (list (gensym)) `()))
  805.           )
  806.       (values
  807.         `(,@SM1 ,indicatorvar ,@defaultvar-list)
  808.         `(,@SM2 ,indicator    ,@(if default `(,default) `()))
  809.         `(,storevar)
  810.         `(LET ((,(first SM3) (SYS::%PUTF ,SM5 ,indicatorvar ,storevar)))
  811.            ,@defaultvar-list ; defaultvar zum Schein auswerten
  812.            (WHEN ,(first SM3) ,SM4)
  813.            ,storevar
  814.          )
  815.         `(GETF ,SM5 ,indicatorvar ,@defaultvar-list)
  816. ) ) ) )
  817. ;-------------------------------------------------------------------------------
  818. (defsetf GETHASH (key hashtable &optional default) (value)
  819.   (let ((storeform `(SYSTEM::PUTHASH ,key ,hashtable ,value)))
  820.     (if default
  821.       `(PROGN ,default ,storeform) ; default wird nur zum Schein ausgewertet
  822.       `,storeform
  823. ) ) )
  824. ;-------------------------------------------------------------------------------
  825. #| ; siehe oben:
  826. (defun SYSTEM::%SET-DOCUMENTATION (symbol doctype value)
  827.   (unless (function-name-p symbol)
  828.     (error-of-type 'error
  829.       (DEUTSCH "Das ist als erstes Argument unzulΣssig, da kein Symbol: ~S"
  830.        ENGLISH "first argument ~S is illegal, not a symbol"
  831.        FRANCAIS "Le premier argument ~S est invalide car ce n'est pas un symbole.")
  832.       symbol
  833.   ) )
  834.   (setq symbol (get-funname-symbol symbol))
  835.   (if (null value)
  836.     (progn (remf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype) nil)
  837.     (setf (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype) value)
  838. ) )
  839. |#
  840. (defsetf documentation SYSTEM::%SET-DOCUMENTATION)
  841. ;-------------------------------------------------------------------------------
  842. (defsetf fill-pointer SYSTEM::SET-FILL-POINTER)
  843. ;-------------------------------------------------------------------------------
  844. (defsetf readtable-case SYSTEM::SET-READTABLE-CASE)
  845. ;-------------------------------------------------------------------------------
  846. (defsetf SYMBOL-VALUE SET)
  847. ;-------------------------------------------------------------------------------
  848. (defsetf SYMBOL-FUNCTION SYSTEM::%PUTD)
  849. ;-------------------------------------------------------------------------------
  850. (defsetf SYMBOL-PLIST SYSTEM::%PUTPLIST)
  851. ;-------------------------------------------------------------------------------
  852. (defun SYSTEM::SET-FDEFINITION (name value)
  853.   (setf (symbol-function (get-funname-symbol name)) value)
  854. )
  855. (defsetf FDEFINITION SYSTEM::SET-FDEFINITION)
  856. ;-------------------------------------------------------------------------------
  857. (defsetf MACRO-FUNCTION (symbol) (value)
  858.   `(PROGN
  859.      (SETF (SYMBOL-FUNCTION ,symbol) (CONS 'SYSTEM::MACRO ,value))
  860.      (REMPROP ,symbol 'SYSTEM::MACRO)
  861.      ,value
  862.    )
  863. )
  864. ;-------------------------------------------------------------------------------
  865. (defsetf CHAR SYSTEM::STORE-CHAR)
  866. (defsetf SCHAR SYSTEM::STORE-SCHAR)
  867. (defsetf BIT SYSTEM::STORE)
  868. (defsetf SBIT SYSTEM::STORE)
  869. (defsetf SUBSEQ (sequence start &optional end) (value)
  870.   `(PROGN (REPLACE ,sequence ,value :START1 ,start :END1 ,end) ,value)
  871. )
  872. ;-------------------------------------------------------------------------------
  873. (define-setf-method char-bit (char name &environment env)
  874.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method char env)
  875.     (let* ((namevar (gensym))
  876.            (storevar (gensym)))
  877.       (values `(,@SM1 ,namevar)
  878.               `(,@SM2 ,name)
  879.               `(,storevar)
  880.               `(LET ((,(first SM3) (SET-CHAR-BIT ,SM5 ,namevar ,storevar)))
  881.                  ,SM4
  882.                  ,storevar
  883.                )
  884.               `(CHAR-BIT ,SM5 ,namevar)
  885. ) ) ) )
  886. ;-------------------------------------------------------------------------------
  887. (define-setf-method LDB (bytespec integer &environment env)
  888.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method integer env)
  889.     (let* ((bytespecvar (gensym))
  890.            (storevar (gensym)))
  891.       (values (cons bytespecvar SM1)
  892.               (cons bytespec SM2)
  893.               `(,storevar)
  894.               `(LET ((,(first SM3) (DPB ,storevar ,bytespecvar ,SM5)))
  895.                  ,SM4
  896.                  ,storevar
  897.                )
  898.               `(LDB ,bytespecvar ,SM5)
  899. ) ) ) )
  900. ;-------------------------------------------------------------------------------
  901. (define-setf-method MASK-FIELD (bytespec integer &environment env)
  902.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method integer env)
  903.     (let* ((bytespecvar (gensym))
  904.            (storevar (gensym)))
  905.       (values (cons bytespecvar SM1)
  906.               (cons bytespec SM2)
  907.               `(,storevar)
  908.               `(LET ((,(first SM3) (DEPOSIT-FIELD ,storevar ,bytespecvar ,SM5)))
  909.                  ,SM4
  910.                  ,storevar
  911.                )
  912.               `(MASK-FIELD ,bytespecvar ,SM5)
  913. ) ) ) )
  914. ;-------------------------------------------------------------------------------
  915. (define-setf-method THE (type place &environment env)
  916.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  917.     (values SM1 SM2 SM3
  918.             (subst `(THE ,type ,(first SM3)) (first SM3) SM4)
  919.             `(THE ,type ,SM5)
  920. ) ) )
  921. ;-------------------------------------------------------------------------------
  922. (define-setf-method APPLY (fun &rest args &environment env)
  923.   (if (and (listp fun)
  924.            (eq (list-length fun) 2)
  925.            (eq (first fun) 'FUNCTION)
  926.            (symbolp (second fun))
  927.       )
  928.     (setq fun (second fun))
  929.     (error-of-type 'program-error
  930.       (DEUTSCH "SETF von APPLY ist nur fⁿr Funktionen der Form #'symbol als Argument definiert."
  931.        ENGLISH "SETF APPLY is only defined for functions of the form #'symbol."
  932.        FRANCAIS "Un SETF de APPLY n'est dΘfini que pour les fonctions de la forme #'symbole.")
  933.   ) )
  934.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method (cons fun args) env)
  935.     (unless (eq (car (last args)) (car (last SM2)))
  936.       (error-of-type 'program-error
  937.         (DEUTSCH "APPLY von ~S kann nicht als 'SETF-Place' aufgefa▀t werden."
  938.          ENGLISH "APPLY on ~S is not a SETF place."
  939.          FRANCAIS "APPLY de ~S ne peux pas Ωtre considΘrΘ comme une place modifiable.")
  940.         fun
  941.     ) )
  942.     (let ((item (car (last SM1)))) ; 'item' steht fⁿr eine Argumentliste!
  943.       (labels ((splice (arglist)
  944.                  ; Wⁿrde man in (LIST . arglist) das 'item' nicht als 1 Element,
  945.                  ; sondern gespliced, sozusagen als ',@item', haben wollen, so
  946.                  ; brΣuchte man die Form, die (splice arglist) liefert.
  947.                  (if (endp arglist)
  948.                    'NIL
  949.                    (let ((rest (splice (cdr arglist))))
  950.                      (if (eql (car arglist) item)
  951.                        ; ein (APPEND item ...) davorhΣngen, wie bei Backquote
  952.                        (backquote-append item rest)
  953.                        ; ein (CONS (car arglist) ...) davorhΣngen, wie bei Backquote
  954.                        (backquote-cons (car arglist) rest)
  955.               )) ) ) )
  956.         (flet ((call-splicing (form)
  957.                  ; ersetzt einen Funktionsaufruf form durch einen, bei dem
  958.                  ; 'item' nicht 1 Argument, sondern eine Argumentliste liefert
  959.                  (let ((fun (first form))
  960.                        (argform (splice (rest form))))
  961.                    ; (APPLY #'fun argform) vereinfachen:
  962.                    ; (APPLY #'fun NIL) --> (fun)
  963.                    ; (APPLY #'fun (LIST ...)) --> (fun ...)
  964.                    ; (APPLY #'fun (CONS x y)) --> (APPLY #'fun x y)
  965.                    ; (APPLY #'fun (LIST* ... z)) --> (APPLY #'fun ... z)
  966.                    (if (or (null argform)
  967.                            (and (consp argform) (eq (car argform) 'LIST))
  968.                        )
  969.                      (cons fun (cdr argform))
  970.                      (list* 'APPLY
  971.                             (list 'FUNCTION fun)
  972.                             (if (and (consp argform)
  973.                                      (or (eq (car argform) 'LIST*)
  974.                                          (eq (car argform) 'CONS)
  975.                                 )    )
  976.                               (cdr argform)
  977.                               (list argform)
  978.               )) ) ) )      )
  979.           (values SM1 SM2 SM3 (call-splicing SM4) (call-splicing SM5))
  980. ) ) ) ) )
  981. ;-------------------------------------------------------------------------------
  982. ; ZusΣtzliche Definitionen von places
  983. ;-------------------------------------------------------------------------------
  984. (define-setf-method funcall (fun &rest args &environment env)
  985.   (unless (and (listp fun)
  986.                (eq (list-length fun) 2)
  987.                (let ((fun1 (first fun)))
  988.                  (or (eq fun1 'FUNCTION) (eq fun1 'QUOTE))
  989.                )
  990.                (symbolp (second fun))
  991.                (setq fun (second fun))
  992.           )
  993.     (error-of-type 'program-error
  994.       (DEUTSCH "SETF von FUNCALL ist nur fⁿr Funktionen der Form #'symbol definiert."
  995.        ENGLISH "SETF FUNCALL is only defined for functions of the form #'symbol."
  996.        FRANCAIS "Un SETF de FUNCALL n'est dΘfini que pour les fonctions de la forme #'symbole.")
  997.   ) )
  998.   (get-setf-method (cons fun args) env)
  999. )
  1000. ;-------------------------------------------------------------------------------
  1001. (defsetf GET-DISPATCH-MACRO-CHARACTER
  1002.          (disp-char sub-char &optional (readtable '*READTABLE*)) (value)
  1003.   `(PROGN (SET-DISPATCH-MACRO-CHARACTER ,disp-char ,sub-char ,value ,readtable) ,value)
  1004. )
  1005. ;-------------------------------------------------------------------------------
  1006. (defsetf long-float-digits SYSTEM::%SET-LONG-FLOAT-DIGITS)
  1007. ;-------------------------------------------------------------------------------
  1008. (defsetf DEFAULT-DIRECTORY () (value)
  1009.   `(PROGN (CD ,value) ,value)
  1010. )
  1011. ;-------------------------------------------------------------------------------
  1012. #+LOGICAL-PATHNAMES
  1013. (defsetf logical-pathname-translations set-logical-pathname-translations)
  1014. ;-------------------------------------------------------------------------------
  1015. ; Handhabung von (SETF (VALUES place1 ... placek) form)
  1016. ; --> (MULTIPLE-VALUE-BIND (dummy1 ... dummyk) form
  1017. ;       (SETF place1 dummy1 ... placek dummyk)
  1018. ;       (VALUES dummy1 ... dummyk)
  1019. ;     )
  1020. (define-setf-method VALUES (&rest subplaces &environment env)
  1021.   (multiple-value-bind (temps vals stores storeforms accessforms)
  1022.       (setf-VALUES-aux subplaces env)
  1023.     (values temps
  1024.             vals
  1025.             stores
  1026.             `(VALUES ,@storeforms)
  1027.             `(VALUES ,@accessforms)
  1028. ) ) )
  1029. (defun setf-VALUES-aux (places env)
  1030.   (do ((temps nil)
  1031.        (vals nil)
  1032.        (stores nil)
  1033.        (storeforms nil)
  1034.        (accessforms nil)
  1035.        (placesr places))
  1036.       ((atom placesr)
  1037.        (setq temps (nreverse temps))
  1038.        (setq vals (nreverse vals))
  1039.        (setq stores (nreverse stores))
  1040.        (setq storeforms (nreverse storeforms))
  1041.        (setq accessforms (nreverse accessforms))
  1042.        (values temps vals stores storeforms accessforms)
  1043.       )
  1044.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  1045.         (get-setf-method (pop placesr) env)
  1046.       (setq temps (revappend SM1 temps))
  1047.       (setq vals (revappend SM2 vals))
  1048.       (setq stores (revappend SM3 stores))
  1049.       (setq storeforms (cons SM4 storeforms))
  1050.       (setq accessforms (cons SM5 accessforms))
  1051. ) ) )
  1052. ;-------------------------------------------------------------------------------
  1053. ; Analog zu (MULTIPLE-VALUE-SETQ (var1 ... vark) form) :
  1054. ; (MULTIPLE-VALUE-SETF (place1 ... placek) form)
  1055. ; --> (VALUES (SETF (VALUES place1 ... placek) form))
  1056. ; --> (MULTIPLE-VALUE-BIND (dummy1 ... dummyk) form
  1057. ;       (SETF place1 dummy1 ... placek dummyk)
  1058. ;       dummy1
  1059. ;     )
  1060. (defmacro multiple-value-setf (places form &environment env)
  1061.   (multiple-value-bind (temps vals stores storeforms accessforms)
  1062.       (setf-VALUES-aux places env)
  1063.     (declare (ignore accessforms))
  1064.     `(LET* ,(mapcar #'list temps vals)
  1065.        (MULTIPLE-VALUE-BIND ,stores ,form
  1066.          ,@storeforms
  1067.          ,(first stores) ; (null stores) -> NIL -> Wert NIL
  1068.      ) )
  1069. ) )
  1070. ;-------------------------------------------------------------------------------
  1071.  
  1072.